home *** CD-ROM | disk | FTP | other *** search
/ Games of Daze / Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso / x2ftp / msdos / source / gfxfx / 3dxhexls.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-06-18  |  3.2 KB  |  106 lines
  1.  
  2. {$r-,n+,e-}
  3. program polygoned_and_shaded_octagon;
  4. { 3d real object with real light source, NOT! ;-) }
  5. uses
  6.   crt,x3dunit;
  7. const
  8.   nofpolys=9; { number of polygons -1 }
  9.   nofpoints=11; { number of points -1 }
  10.   lscoords:record x,y,z:word; end=(x:0; y:0; z:100); { light source coords }
  11.   point:array[0..nofpoints,0..2] of integer=(
  12.     (-20,-20, 30),( 20,-20, 30),( 40,-40,  0),( 20,-20,-30),
  13.     (-20,-20,-30),(-40,-40,  0),(-20, 20, 30),( 20, 20, 30),
  14.     ( 40, 40,  0),( 20, 20,-30),(-20, 20,-30),(-40, 40,  0));
  15.   planes:array[0..nofpolys,0..3] of byte=(
  16.     (0,1,7,6),(1,2,8,7),(9,8,2,3),(10,9,3,4),(10,4,5,11),
  17.     (6,11,5,0),(0,1,2,5),(5,2,3,4),(6,7,8,11),(11,8,9,10));
  18. type
  19.   polytype=array[0..nofpolys] of integer;
  20. var
  21.   polyz,pind:polytype;
  22.  
  23. { -------------------------------------------------------------------------- }
  24.  
  25. procedure quicksort(lo,hi:integer);
  26.  
  27. procedure sort(l,r:integer);
  28. var i,j,x,y:integer;
  29. begin
  30.   i:=l; j:=r; x:=polyz[(l+r) div 2];
  31.   repeat
  32.     while polyz[i]<x do inc(i);
  33.     while x<polyz[j] do dec(j);
  34.     if i<=j then begin
  35.       y:=polyz[i]; polyz[i]:=polyz[j]; polyz[j]:=y;
  36.       y:=pind[i]; pind[i]:=pind[j]; pind[j]:=y;
  37.       inc(i); dec(j);
  38.     end;
  39.   until i>j;
  40.   if l<j then sort(l,j);
  41.   if i<r then sort(i,r);
  42. end;
  43.  
  44. begin
  45.   sort(lo,hi);
  46. end;
  47.  
  48. { -------------------------------------------------------------------------- }
  49.  
  50. procedure rotate_cube;
  51. const xst=0.08; yst=0.02; zst=-0.03;
  52. var
  53.   xp,yp,zp:array[0..nofpoints] of integer;
  54.   x,y,z,i,j,k,phix,phiy,phiz:real;
  55.   n:byte;
  56. begin
  57.   address:=0;
  58.   phix:=0; phiy:=0; phiz:=0;
  59.   fillchar(xp,sizeof(xp),0);
  60.   fillchar(yp,sizeof(yp),0);
  61.   fillchar(z,sizeof(z),0);
  62.   repeat
  63.     retrace;
  64.     setborder(50);
  65.     for n:=0 to nofpoints do begin
  66.       i:=cos(phiy)*point[n,0]-sin(phiy)*point[n,2];
  67.       j:=cos(phiz)*point[n,1]-sin(phiz)*i;
  68.       k:=cos(phiy)*point[n,2]+sin(phiy)*point[n,0];
  69.       x:=cos(phiz)*i+sin(phiz)*point[n,1];
  70.       y:=cos(phix)*j+sin(phix)*k;
  71.       z:=cos(phix)*k-sin(phix)*j;
  72.       xp[n]:=160+round((-x*dist)/(z-dist));
  73.       yp[n]:=100+round((-y*dist)/(z-dist));
  74.       zp[n]:=round(z);
  75.     end;
  76.     for n:=0 to nofpolys do begin
  77.       polyz[n]:=(zp[planes[n,0]]+zp[planes[n,1]]+zp[planes[n,2]]+zp[planes[n,3]]) div 4;
  78.       pind[n]:=n;
  79.     end;
  80.     quicksort(0,nofpolys);
  81.     address:=16000-address;
  82.     setaddress(address);
  83.     cls;
  84.     for n:=5 to nofpolys do
  85.       polygon(xp[planes[pind[n],0]],yp[planes[pind[n],0]],
  86.               xp[planes[pind[n],1]],yp[planes[pind[n],1]],
  87.               xp[planes[pind[n],2]],yp[planes[pind[n],2]],
  88.               xp[planes[pind[n],3]],yp[planes[pind[n],3]],polyz[n]+15);
  89.     phix:=phix+xst; if phix<0 then phix:=phix+(2*pi) else if phix>(2*pi) then phix:=phix-(2*pi);
  90.     phiy:=phiy+yst; if phiy<0 then phiy:=phiy+(2*pi) else if phiy>(2*pi) then phiy:=phiy-(2*pi);
  91.     phiz:=phiz+zst; if phiz<0 then phiz:=phiz+(2*pi) else if phiz>(2*pi) then phiz:=phiz-(2*pi);
  92.     setborder(0);
  93.   until keypressed;
  94. end;
  95.  
  96. { -------------------------------------------------------------------------- }
  97.  
  98. var i:byte;
  99. begin
  100.   setmodex;
  101.   border:=false;
  102.   for i:=1 to 63 do setpal(i,i div 4,i div 2,i);
  103.   rotate_cube;
  104.   textmode(lastmode);
  105. end.
  106.